home *** CD-ROM | disk | FTP | other *** search
/ Pascal Super Library / Pascal Super Library (CW International)(1997).bin / LIBRARY / SWDOS12 / SWDOS.PAS < prev    next >
Pascal/Delphi Source File  |  1995-02-10  |  22KB  |  757 lines
  1. {******************************************************************}
  2. {*                         SWDOS.PAS                              *}
  3. {*                  SoftWeyr enhanced DOS toolbox                 *}
  4. {*                        version 1.2                             *}
  5. {*                 Copyright (c) by SoftWeyr,1994-95              *}
  6. {******************************************************************}
  7. {$F-}
  8. {$IFDEF Ver70}
  9. {$T-}
  10. {$ENDIF}
  11. unit SWDOS;
  12. Interface
  13. uses DOS;
  14. Const
  15.   {Memory allocation strategies}
  16.   msFirstFitLow=0;{In conventional memory from lowest address}
  17.   msBestFitLow=1;{In best block of conventional  memory}
  18.   msLastFitLow=2;{In conventional memory from highest address}
  19.   msFirstFitHighOnly=$40;{Only in UMB from lower end}
  20.   msBestFitHighOnly=$41;
  21.   msLastFitHighOnly=$42;
  22.   msFirstFitHigh=$80;{Try in UMB, if failed, try in conventional}
  23.   msBestFitHigh=$81;
  24.   msLastFitHigh=$82;
  25.   {Standard DOS devices}
  26.   STDIN=0;
  27.   STDOUT=1;
  28.   STDERR=2;
  29.   STDPRN=3;
  30.   STDAUX=4;
  31.   STDAUXin=5;
  32. var
  33.      ZeroWord:Word;{Don't change this and folllowing definition and value
  34.                        of this constant!}
  35.      Environment:Word;{Contain Segment address of currently availiable env}
  36. {-------------  operations with file via its name -------------------------}
  37. Procedure RenameFile(OldName,NewName:String);
  38. Procedure EraseFile(FileName:String);
  39. Procedure SetFileAttr(FileName:String;Attr:Word);
  40. Function GetFileAttr(FileName:String):Word;
  41. Procedure SetFileTime(FileName:String;DateTime:LongInt);
  42. Procedure GetFileTime(FileName:String;var DateTime:Longint);
  43. {-------------  operations with file via its handle -----------------------}
  44. {Useful, for example for operate with TDOSStream}
  45. Procedure SetHandleTime(Handle:Word;DateTime:LongInt);
  46. Procedure GetHandleTime(Handle:Word;var DateTime:Longint);
  47. {-------------------- other file operations ------------------------------}
  48. Procedure MaxFiles(Count:Integer);
  49. {Set maximal count of availiable file handlers}
  50. Procedure AssignTemp(var F;TempDir:String);
  51. {Creats a temporary  file with unique name in specified directory and
  52.  assignes it to file variable F}
  53. Procedure CloseTemp(var F);
  54. {Closes and erases file}
  55. Function GetFileName(var F):String;
  56. {Returns name of assigned file, either text or binary}
  57. {------ STD Dos Devices & TEXT file management ---------------------}
  58. Procedure OpenSTD(var F:Text;Device:Word);
  59. {Opens text file as standard dos device}
  60. Procedure StdWrite(Device:Word;S:String);
  61. {Writes string to standard dos device}
  62. Function Redirected(var F:TExt):Boolean;
  63. {Checks for redirection of STDIN or STDOUT}
  64. Procedure CloseHandle(Handle:Word);
  65. {Closes the given handle}
  66. Procedure SetPagingMode(var F :Text; H :Integer; Message
  67.                                                       :String);
  68. Procedure EndPagingMode(var F:Text);
  69. {Set/Reset autostop after each H strings}
  70. Function GetStr(var F:Text):String;
  71. {Readln(F,S) as function. Sometimes useful}
  72. Procedure Tee(var F:Text);
  73. {Duplicates output to specified file to STDOUT. Useful if file is
  74.  assigned trough AssignCRT or AssignDevice and StDOut is redirected.
  75.  Tee and setPaging mode cannot be used at same time, even with different
  76.  files}
  77. var DuplicateOutput:Boolean;
  78. {Set it to false if you want temporary stop Tee file}
  79. {-------------- KeyBoard Read though DOS ---------------------------------}
  80.  Function DOSReadKey:char;inline
  81.  {Four bytes only shorter than far CALL}
  82. ($B4/$08    {MOV AH,8}
  83. /$CD/$21);  {INT 21H}
  84. Function DOSKeyPressed:Boolean;inline
  85. ($B4/$0B    {MOV AH,0BH}
  86. /$CD/$21    {INT 21H}
  87. /$24/$01);  {AND AL,1;True = 1, but not $FF, as  DOS think,
  88.                                but  False - really  0}
  89. Function ReadKeyWithEcho:char;inline($B4/$01/$CD/$21);
  90.  
  91. {-------------- operations with enviroment -------------------------------}
  92. {Make Environment of parent process availiable for reading and modification}
  93. Procedure AccessParentEnv;
  94. {Make current Environment availiiable again after call of prevois routine}
  95. Procedure AccessCurrentEnv;
  96. {Make Root Environment availiable for reading and modification}
  97. Procedure AccessRootEnv;
  98. {Deallocates environment block and lets DOS use its space for other purposes}
  99. {very useful for TSR's}
  100. Procedure FreeEnv;
  101. {Returns size of currently availiavle environment block}
  102. Function GetEnvSize:word;
  103. {Returns number of Environment strings}
  104. Function GetEnvCount:Integer;
  105. {Returns number of free bytes in environment block}
  106. Function GetEnvSpace:word;
  107. {Return N-th String from environment}
  108. Function GetEnvStrN(N:Integer):String;
  109. {Return Value of specified environment variable}
  110. Function GetEnvStr(VarName:String):String;
  111. {Sets new value of specified environment variable}
  112. {Returns 20 in DosError if out of environment space}
  113. Procedure SetEnvStr(VarName,Value:String);
  114. {Return Path name of owner of currently availiable environment}
  115. Function GetProgName:String;
  116. {Return command line of owner of currently availiable environment}
  117. Function GetCommandLine:String;
  118. {Return command line addres of owner of currently availiable environment}
  119. Function CommandLineAddress:Pointer;
  120.  
  121. {Returns addres of prevois int 22-24h handler}
  122. Function OldInt22H:Pointer;
  123. Function OldInt23H:Pointer;
  124. Function OldInt24H:Pointer;
  125. {operation with DOS memory meneger}
  126. Procedure SetMemTop(MemTop:Pointer);
  127. {Analog of procedure from Turbo Vision unit Memory. Be very careful with
  128.  TP versions prior 6.0. freelist may be destroyed by this call }
  129. Function DosAlloc(Size:Word):Pointer;
  130. Procedure DosFree(P:Pointer);
  131. {Allocates /deallocates memory block on DOS level}
  132. Procedure SetAllocationStrategy(Strategy:Word);
  133. {Changes DOS allocation strategy see msXXX constants in this unit}
  134. {Please restore original allocation strategy before exiting from program}
  135. Function GetAllocationStrategy:Word;
  136. {Returns current DOS Allocation Strategy}
  137. Function GetUMBLink:Boolean;
  138. {Returns True if UMB usage allowed}
  139. Procedure SetUMBLink(Allow:Boolean);
  140. {Sets UMB usage state}
  141. Function Upcase(ch:Char):Char;
  142. {UpperCases character in differece from System.Upcase correctly works with
  143.  national characters if COUNTRY was defined in  CONFIG.SYS}
  144. Function StUpcase(S:STring):String;
  145. {UpperCases a string}
  146. {$IFDEF Ver70}
  147.  Function StrUpper(Str:PChar):PChar;
  148. {$ENDIF}
  149. {-------------------------- File name management ---------------------------}
  150. Function JustFileName(FileName:String):String;
  151. {Extracts name with extension from given filename (Removes any pathname)}
  152. Function JustName(FileName:String):String;
  153. {Extract name without extension from given filename}
  154. Function JustExtension(FileName:String):String;
  155. {Extract extension from given file name}
  156. Function JustPathName(FileName:String):String;
  157. {Extract pathname from given fileName}
  158. Function DefaultExtension(FileName,Extension:String):String;
  159. {if given filename has no extension, appends given extension}
  160. Function ForceExtension(FileName,Extension:String):String;
  161. {Sets extension to given}
  162. Function ExpandFileName(FileName,DefaultExt,DefaultDir:String):String;
  163. { Appends extension if no one specified and search file in list of
  164.   default directories. Returns '' if not found or full name}
  165. {-------------- Text file management ---------------------}
  166. Procedure TextSeek(var F : Text; Target : LongInt);
  167.     {-Do a Seek for a text file opened for input. Returns False in case of I/O
  168.       error.}
  169. Function TextPos(var F:Text):Longint;
  170.  {Returns current positon of text file, opened both for input ir output.
  171.   Returns -1 in case of error} 
  172. Procedure AssignMemory(var F:Text;var Buffer;BufSize:Word);
  173. {Assigns memory buffer to file.  Futher you can do Reset or Rewrite etc.
  174.  Do not forget remove buffer after closing if it is dynamically allocated.
  175.  if you want read from this file, fill buffer by anything appropriate before}
  176.  
  177. Procedure LoadTextFile(var F:Text);
  178. {Loads a text file. Make usial Assign before and usial Reset after
  179.  (You may Reset it as many time as you need without any disk access
  180.  Close by CloseLoaded
  181.   or do With TextRec(F) do
  182.           FreeMem(BufPtr,BufSize);
  183.   after close
  184.   if file larger then 64 K or not enough memory,IOResult would return
  185.    8 (Not Enough Memory) and file would be open as usial}
  186.  
  187. Procedure CloseLoaded(var F:Text);
  188. {Closes file and deallocates it's buffer}
  189. {-----------------Single drive processing----------------------------}
  190. Function GetDriveLetter(Device:Byte):Char;
  191. {Return drive letter, currently associated with specified device}
  192. {Device - 0 :Default, 1-A 2-B etc. Returns '@' in cad=se of error
  193.  associated with device}
  194. Function IsDriveMappable(Device:Byte):Boolean;
  195. {Returns True if more than one letter associated with given device}
  196. Procedure SetDriveLetter(DriveLet:Char);
  197. {if device can be associated with more than one letter i.e A: B:,
  198.  tells dos, which letter must be used}
  199. Implementation
  200. {==========================================================================}
  201. {$F+}
  202. {$L Rename}
  203. Procedure RenameFile(OldName,NewName:String);external;
  204. {$L Erase}
  205. Procedure EraseFile(FileName:String);external;
  206. {$L Attr}
  207. Procedure SetFileAttr(FileName:String;Attr:Word);external;
  208. Function GetFileAttr(FileName:String):Word;external;
  209. {$L FTime}
  210. Procedure SetFileTime(FileName:String;DateTime:LongInt);External;
  211. Procedure GetFileTime(FileName:String;var DateTime:Longint);external;
  212. {$L HTime}
  213. Procedure SetHandleTime(Handle:Word;DateTime:LongInt);External;
  214. Procedure GetHandleTime(Handle:Word;var DateTime:Longint);External;
  215. {$L Environ.obj}
  216. Procedure AccessParentEnv;External;
  217. Function GetEnvSize:word;External;
  218. {$L MaxFiles}
  219. Procedure MaxFiles(Count:Integer);external;
  220. {$L MemTop}
  221. Procedure SetMemTop(MemTop:Pointer);External;
  222. {$L DosAlloc}
  223. Function DosAlloc(Size:Word):Pointer;External;
  224. {$L DosFree}
  225. Procedure DosFree(P:Pointer);external;
  226. {$L STRATEGY}
  227. Procedure SetAllocationStrategy(Strategy:Word);External;
  228. Function GetAllocationStrategy:Word;External;
  229. {$L UMBLink}
  230. Function GetUMBLink:Boolean;External;
  231. Procedure SetUMBLink(Allow:Boolean);External;
  232. {$L Upcase}
  233. Function Upcase(ch:Char):Char;external;
  234. {UpperCases character in differece from System.Upcase correctly works with
  235.  national characters if COUNTRY was defined in  CONFIG.SYS}
  236. Function StUpcase(S:STring):String;External;
  237. {UpperCases a string}
  238. {$IFDEF Ver70}
  239.   {$L Upcase7}
  240.   Function StrUpper(Str:PChar):PChar;external;
  241. {$ENDIF}
  242. {$L Asciiz}
  243. Procedure Asciiz;external;
  244. {$L DevWrite}
  245. Procedure StdWrite(Device:Word;S:STring);External;
  246. {$L CLose}
  247. Procedure CloseHandle(Handle:Word);External;
  248. {$L REDIR}
  249. Function Redirected(var F:TExt):Boolean;External;
  250. {-------------- Text file position management ---------------------}
  251. Procedure TextSeek(var F : Text; Target : LongInt);external;
  252. {$L TEXTSEEK.OBJ}
  253. Function TextPos(var F : Text): LongInt;external;
  254. {$L TEXTPOS.OBJ}
  255. {------------ Single drive systems ------------------}
  256. Function GetDriveLetter(Device:Byte):Char;External;
  257. Function IsDriveMappable(Device:Byte):Boolean;External;
  258. Procedure SetDriveLetter(DriveLet:Char);External;
  259. {$L ONEDRIVE.OBJ}
  260. {$F-}
  261.  
  262. type EnvBlock=array[0..32767]of char;
  263.      EnvPtr=^EnvBlock;
  264. var Env:EnvPtr absolute ZeroWord;
  265.     EnvPos:Word;
  266. {Local environment operation procedures}
  267. Procedure FreeEnv;
  268. begin
  269.  DosFree(Env);
  270. end;
  271. Procedure SkipLine;
  272. begin
  273.  While Env^[EnvPos]<>#0 do inc(EnvPos);
  274.  Inc(EnvPos);
  275. end;
  276. Function CopyStr:String;
  277. var I:Integer;
  278. begin
  279.  i:=0;
  280.  While (I<255)and(Env^[EnvPos]<>#0) do
  281.   begin
  282.    inc(i);
  283.    CopyStr[i]:=Env^[EnvPos];
  284.    Inc(EnvPos);
  285.   end;
  286.  CopyStr[0]:=chr(i);
  287. end;
  288. Procedure FindEnvStr(var VarName:string);
  289. Label 1;
  290. var i:Integer;
  291. begin
  292.  EnvPos:=0;
  293.  VarName:=StUpCase(VarName);
  294.  While Env^[EnvPos]<>#0 do
  295.   begin
  296.    i:=1;
  297.    While (Env^[EnvPos]=VarName[i])and(i<=Length(VarName)) do
  298.     begin
  299.      inc(i);
  300.      Inc(EnvPos);
  301.     end;
  302.    if (i=Succ(Length(VarName)))and(Env^[EnvPos]='=')then Goto 1
  303.     else SkipLine;
  304.   end;
  305.  1:
  306. end;
  307.  
  308. Procedure StoreStr(S:String);
  309. var i:Integer;
  310. begin
  311.  For i:=1 to Length(S) do
  312.   begin
  313.    Env^[EnvPos]:=S[i];
  314.    Inc(EnvPos);
  315.   end;
  316. end;
  317. {Interface environment operation procedures}
  318. Function GetEnvCount:Integer;
  319. var I:Integer;
  320. begin
  321.  EnvPos:=0;
  322.  I:=0;
  323.  While Env^[EnvPos]<>#0 do
  324.   begin
  325.    SkipLine;
  326.    Inc(i);
  327.   end;
  328.  GetEnvCount:=i;
  329. end;
  330. Function GetEnvSpace:Word;
  331. begin
  332.  EnvPos:=0;
  333.  While Env^[EnvPos]<>#0 do
  334.   SkipLine;
  335.  inc(EnvPos,3);
  336.  SkipLine;
  337.  GetEnvSpace:=GetEnvSize-EnvPos;
  338. end;
  339. Function GetEnvStrN(N:Integer):String;
  340. Label 1;
  341. var I:Integer;
  342. begin
  343.  EnvPos:=0;
  344.  For I:=2 to n do
  345.  begin
  346.   SkipLine;
  347.   if Env^[EnvPos]=#0 then goto 1;
  348.  end;
  349.  1:GetEnvStrN:=CopyStr;
  350. end;
  351. Function GetEnvStr(VarName:String):String;
  352. begin
  353.  FindEnvStr(VarName);
  354.  if Env^[EnvPos]=#0 then GetEnvStr:='' else
  355.   begin
  356.  Inc(EnvPos);
  357.  GetEnvStr:=CopyStr;
  358.  end;
  359. end;
  360. Procedure SetEnvStr(VarName,Value:String);
  361. var Lastpos,Space,k,i,n:word;
  362. Procedure MoveEnv(Src,Dst:word);
  363. var i:integer;
  364. begin
  365.  if Src>Dst then
  366.    For i:=Src to LastPos do
  367.     begin
  368.      Env^[Dst]:=Env^[i];
  369.      Inc(Dst);
  370.     end
  371.   else
  372.  if Src<Dst then
  373.   begin
  374.    Dst:=LastPos-Src+Dst;
  375.    For i:=LastPos downto Src do
  376.     begin
  377.      Env^[Dst]:=Env^[i];
  378.      Dec(Dst);
  379.     end;
  380.   end;
  381. end;
  382. begin
  383.  Space:=GetEnvSpace;
  384.  LastPos:=EnvPos;
  385.  FindEnvStr(VarName);
  386.  if Value='' then
  387.   begin
  388.    {Clearing environment variable}
  389.    if Env^[EnvPos]=#0 then exit;{Variable is not defined}
  390.    k:=EnvPos;
  391.    {Find begin of line}
  392.    While (k>0) and (Env^[k]<>#0)do dec(k);
  393.    if Env^[k]=#0 then inc(K);
  394.    {Find end of Line}
  395.    SkipLine;
  396.    {Move rest of Environment}
  397.    MoveEnv(EnvPos,k);
  398.   end
  399.   else
  400.  begin
  401.   {Set new Value}
  402.   if Env^[EnvPos]=#0 then
  403.    begin
  404.     {Variable is not already defined}
  405.     k:=Length(VarName)+Length(Value)+2;
  406.     if Space<K then begin DosError:=8;exit end;
  407.     MoveEnv(EnvPos,EnvPos+k);
  408.     StoreStr(VarName);StoreStr('=');StoreStr(Value);StoreStr(#0);
  409.    end
  410.   else
  411.    begin
  412.     k:=Succ(EnvPos);
  413.     SkipLine;
  414.     Dec(EnvPos);
  415.     if Space+EnvPos-k<Length(Value) then begin
  416.      DosError:=8;
  417.      exit;
  418.     end;
  419.    MoveEnv(EnvPos,K+Length(Value));
  420.    EnvPos:=K;
  421.    StoreStr(Value);
  422.   end;
  423.  end;
  424. end;
  425. Function GetProgName:String;
  426. begin
  427.  EnvPos:=0;
  428.  While Env^[EnvPos]<>#0 do SkipLine;
  429.  Inc(EnvPos,3);
  430.  GetProgName:=CopyStr;
  431. end;
  432. Type PtrPtr=^Pointer;
  433.      StrPtr=^String;
  434.      WordPtr=^Word;
  435. Function GetCommandLine:String;
  436. var P:Pointer;
  437. Begin
  438.  
  439.  GetCommandLine:=StrPtr(CommandLineAddress)^;
  440. end;
  441. Function CommandLineAddress:Pointer;
  442. begin
  443.  CommandLineAddress:=Ptr(WordPtr(Ptr(Pred(Environment),1))^,$80)
  444. end;
  445. Function OldInt22H:Pointer;
  446. begin
  447.  OldInt22H:=PtrPtr(Ptr(PrefixSeg,$A))^;
  448. end;
  449.  
  450. Function OldInt23H:Pointer;
  451. begin
  452.  OldInt23H:=PtrPtr(Ptr(PrefixSeg,$E))^;
  453. end;
  454. Function OldInt24H:Pointer;
  455. begin
  456.  OldInt24H:=PtrPtr(Ptr(PrefixSeg,$12))^;
  457. end;
  458. Procedure AccessCurrentEnv;
  459. Type PWord=^Word;
  460. begin
  461.  Environment:=PWord(Ptr(PrefixSeg,$2C))^;
  462. end;
  463. Procedure AccessRootEnv;
  464.     {-Return master environment record}
  465.   var
  466.     Owner : Word;
  467.     Mcb : Word;
  468.     Eseg : Word;
  469.     Done : Boolean;
  470.   begin
  471.  
  472.       {Interrupt $2E points into COMMAND.COM}
  473.       Owner := MemW[0:(2+4*$2E)];
  474.  
  475.       {Mcb points to memory control block for COMMAND}
  476.       Mcb := Owner-1;
  477.       if (Mem[Mcb:0] <> Byte('M')) or (MemW[Mcb:1] <> Owner) then
  478.         Exit;
  479.  
  480.       {Read segment of environment from PSP of COMMAND}
  481.       Eseg := MemW[Owner:$2C];
  482.  
  483.       {Earlier versions of DOS don't store environment segment there}
  484.       if Eseg = 0 then begin
  485.         {Master environment is next block past COMMAND}
  486.         Mcb := Owner+MemW[Mcb:3];
  487.         if (Mem[Mcb:0] <> Byte('M')) or (MemW[Mcb:1] <> Owner) then
  488.           {Not the right memory control block}
  489.           Exit;
  490.         Eseg := Mcb+1;
  491.       end else
  492.         Mcb := Eseg-1;
  493.  
  494.       {Return segment and length of environment}
  495.       Environment := Eseg;
  496.     end;
  497.  
  498.    {$F+}
  499.    Procedure MakeTempFile(var F:File);External;
  500.    {$F-}
  501.    {$L TEMPFILE.OBJ}
  502.  
  503.    Procedure AssignTemp(var F;TempDir:String);
  504.    begin
  505.        if (Length(TempDir)=0) then GetDir(0,TempDir);
  506.     if (TempDir[Length(TempDir)]<>'\') then
  507.      begin
  508.       Inc(TempDir[0]);
  509.       TempDir[Length(TempDir)]:='\';
  510.      end;
  511.     Assign(Text(F),TempDir);
  512.     MakeTempFile(File(F));
  513.   end;
  514.   Procedure CloseTemp(var F);
  515.   begin
  516.    if TextRec(F).Mode<>fmClosed then
  517.      if TextRec(F).CloseFunc<>nil then Close(Text(F)) else Close(File(F));
  518.    Erase(File(F));
  519.   end;
  520.   Function GetFileName(var f):String;
  521.   var S:String;
  522.       i:Integer;
  523.   begin
  524.    S:='';
  525.    i:=0;
  526.    With FileRec(F) do
  527.     while Name[i]<>#0 do begin S:=S+Name[i];inc(i) end;
  528.    GetFileName:=S;
  529.  end;
  530. Procedure OpenStd(var F:Text;Device:Word);
  531. begin
  532.   Assign(F,'');
  533.   Case Device of
  534.   STDIN,STDAUXin:Reset(F);
  535.   STDOUT,STDERR,STDPRN,STDAUX:Rewrite(F);
  536.   else exit;
  537.  end;
  538.  if Device = STDErr then TextRec(F).BufSize:=1 else
  539.  if Device=STDAUXin then Device:=stdAUX;
  540.  TextRec(F).Handle:=Device;
  541. end;
  542. {Set PagingMode variables and functions}
  543. Var OldInOut:Pointer;
  544.     MoreMessage:String[75];
  545.     LineCount:Integer;
  546.     LineLimit:Integer;
  547. Function CallOldInOut(var F:TextRec):Integer;
  548. inline($FF/$1E/OldInOut);
  549. {$F+}
  550. Function PageOut(var F:TextRec):Integer;
  551. {$F-}
  552. var i:Word;BP,BE:Word;R:Integer;S:String;Ch:Char;
  553. begin
  554.  {Scanning buffer, counting LF until BufPos Reached or LineLimit lines found}
  555.  i:=0;
  556.  While (i<F.BufPos) and (LineCount<LineLimit)do
  557.   begin
  558.   {$R-}
  559.    if F.BufPtr^[i]=#10 then inc(LineCount);
  560.    inc(i);
  561.   end;
  562.    BP:=F.BufPos;
  563.    F.BufPos:=i;
  564.    R:=CallOldInOut(F);
  565.    if LineCount=LineLimit then begin
  566.      StdWrite(STDErr,MoreMessage);
  567.      Repeat
  568.       Ch:=Upcase(DOSReadKey);
  569.      Until (Ch='N') or (Ch='Y');
  570.      StdWrite(2,ch);
  571.      LineCount:=0;
  572.      if Ch='Y' then
  573.       begin
  574.        S[0]:=Chr(Length(MoreMessage)+1);
  575.        FillChar(S[1],ord(S[0]),' ');
  576.        StdWrite(StdErr,#13+S+#13);
  577.        PageOut:=R;
  578.        Move(F.BufPtr^[i],F.BufPtr^[0],BP-i);
  579.        F.BufPos:=BP-i;
  580.       end else PageOut:=101;
  581.     end
  582.   else PageOut:=R;
  583. end;
  584. Procedure SetPagingMode(var F :Text; H :Integer; Message:String);
  585. begin
  586.  With TextRec(F) do
  587.   begin
  588.    if OldInOut<>nil then
  589.     begin
  590.      DosError:=4;
  591.      exit;
  592.     end;
  593.    OldInOut:=InOutFunc;
  594.    InOutFunc:=@PageOut;
  595.    FlushFunc:=@PageOut;
  596.    LineLimit:=H;
  597.    LineCount:=0;
  598.    MoreMessage:=Copy(Message,1,75);
  599.   end;
  600. end;
  601. Procedure EndPagingMode(var F:Text);
  602. begin
  603.  With TextRec(F) do
  604.   begin
  605.    if InOutFunc<>@PageOut then
  606.     begin
  607.      DosError:=6;
  608.      Exit;
  609.     end;
  610.    InOutFunc:=OldInOut;
  611.    FlushFunc:=OldInOut;
  612.    OldInOut:=nil;
  613.   end;
  614. end;
  615. Function GetStr(var F:Text):String;
  616. var S:String;
  617. begin
  618.  Readln(F,S);
  619.  GetStr:=S;
  620. end;
  621. Function ExtPos(FileName:String):Integer;
  622. var I:Integer;
  623. begin
  624.  i:=Length(FileName)-3;
  625.  While (I<=Length(FileName))and(FileName[i]<>'.') do inc(i);
  626.  ExtPos:=i;
  627. end;
  628. Function JustFileName(FileName:String):String;
  629. var i:Integer;
  630. begin
  631.  i:=Length(FileName);
  632.  While (i>0)and(FileName[i]<>'\') do Dec(i);
  633.  if FileName[i]='\' then inc(i);
  634.  JustFileName:=Copy(FileName,i,255);
  635. end;
  636. Function JustName(FileName:String):String;
  637. var i:Integer;
  638. begin
  639.   FileName:=JustFileName(FileName);
  640.   Delete(FileName,ExtPos(FileNAme),4);
  641.   JustName:=FileName;
  642. end;
  643. Function JustExtension(FileName:String):String;
  644. var I:Integer;
  645. begin
  646.  JustExtension:=Copy(FileName,ExtPos(FileName)+1,3);
  647. end;
  648. Function JustPathName(FileName:String):String;
  649. var i:Integer;
  650. begin
  651.  i:=Length(FileName);
  652.  While (i>0)and(FileName[i]<>'\') do Dec(i);
  653.  if (i=3) and(FileName[2]=':') then inc(i);
  654.  JustPathName:=Copy(FileName,1,I-1);
  655. end;
  656. Function DefaultExtension(FileName,Extension:String):String;
  657. var i:Integer;
  658. begin
  659.  if ExtPos(FileName)>Length(FileName) then
  660.   DefaultExtension:=FileName+'.'+Extension
  661.  else
  662.   DefaultExtension:=FileName;
  663. end;
  664. Function ForceExtension(FileName,Extension:String):String;
  665. begin
  666.  ForceExtension:=Copy(FileName,1,ExtPos(FileName)-1)+'.'+Extension;
  667. end;
  668. Function ExpandFileName(FileName,DefaultExt,DefaultDir:String):String;
  669. begin
  670.  ExpandFileName:=FSearch(DefaultExtension(FileName,DefaultExt),DefaultDir);
  671. end;
  672. Procedure StdOutWrite(Buf:Pointer;Count:Word);far;external;
  673. {$L DUPOUT}
  674.  
  675. Function NewInOut(var F:TextRec):Integer;far;
  676. begin
  677.  if DuplicateOutput then StdOutWrite(F.BufPtr,F.BufPos);
  678.  NewInOut:=CallOldInOut(F);
  679. end;
  680. Procedure Tee(var F:Text);
  681. begin
  682.  With TextRec(F) do
  683.   begin
  684.    OldInOut:=InOutFunc;
  685.    InOutFunc:=@NewInOut;
  686.    FlushFunc:=@NewInOut;
  687.   end;
  688.  DuplicateOutput:=True;
  689. end;
  690. {$F+}
  691. Function MemInOut(var F:TextRec):Integer;
  692. begin
  693.  F.BufPos:=0;
  694.  F.BufEnd:=0;
  695.  MemInOut:=0;
  696. end;
  697. Function DoNothing(var F:TextRec):integer;
  698. begin
  699.  DoNothing:=0;
  700. end;
  701. Function MemOpen(var F:TextRec):Integer;
  702. begin
  703.  F.CloseFunc:=@DoNothing;
  704.  F.FlushFunc:=@DoNothing;
  705.  F.InOutFunc:=@MemInOut;
  706.  F.BufPos:=0;
  707.  F.BufEnd:=F.BufSize;
  708.  MemOpen:=0;
  709. end;
  710. Procedure AssignMemory(var F:Text;var Buffer;BufSize:Word);
  711. var T:TextRec absolute F;
  712. begin
  713.  T.Mode:=fmClosed;
  714.  T.BufPtr:=@Buffer;
  715.  T.BufSize:=BufSize;
  716.  T.OpenFunc:=@MemOpen;
  717. end;
  718. Procedure LoadTextFile(var F:Text);
  719. var B:File absolute F;
  720.     Size:LongInt;
  721.     SaveHeapError:Pointer;
  722.     P:Pointer;
  723.  
  724. begin
  725.  Reset(B,1);
  726.  Size:=FileSize(B);
  727.  if Size>65521 then
  728.   begin
  729.    Close(B);
  730.    InOutRes:=8;
  731.    exit;
  732.   end;
  733.  if MaxAvail<Size then
  734.   begin
  735.    Close(B);
  736.    InOutRes:=8;
  737.    exit;
  738.   end;
  739.  GetMem(P,Size);
  740.  BlockRead(B,P^,Size);
  741.  Close(B);
  742.  AssignMemory(F,P^,Size);
  743. end;
  744. Procedure CloseLoaded(var F:Text);
  745. begin
  746.  Close(F);
  747.  With TextRec(F) do
  748.    FreeMem(BufPtr,BufSize);
  749. end;
  750.  
  751.  
  752. begin
  753.  AccessCurrentEnv;
  754.  ZeroWord:=0;
  755.  OldInOut:=nil;
  756. end.
  757.